home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Boot / streams2.em < prev    next >
Encoding:
Text File  |  1993-07-13  |  2.8 KB  |  114 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: streams2.em
  4. ;; Date: Sun Jul 11 22:26:25 1993
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule streams2
  11.   (standard0
  12.    list-fns
  13.    )
  14.   ()
  15.   
  16.   (defgeneric stream-class ()
  17.     ((protocol initform nil
  18.            reader stream-class-protocol))
  19.     direct-initargs (direct-stream-fns)
  20.     )
  21.  
  22.   (defclass <protocol-obj> ()
  23.     ((computer initarg computer reader protocol-compute-function)
  24.      (getter initarg getter reader protocol-getter-function))
  25.     constructor (protocol-object computer getter)
  26.     )
  27.  
  28.   (defmethod initialize ((cl stream-class) lst)
  29.     (let ((new-cl (call-next-method))
  30.       (new-fns (scan-args 'direct-stream-fns lst null-argument)))
  31.       (let ((stream-fns (compute-stream-protocol-functions 
  32.              new-cl new-fns )))
  33.     ((setter stream-class-protocol) new-cl stream-fns)
  34.     new-cl)))
  35.  
  36.   (defgeneric inputter (stream))
  37.   (defgeneric outputter (stream c))
  38.   (defgeneric flusher  (stream))
  39.   (defgeneric uninput (stream c))
  40.   (defgeneric positioner (stream))
  41.   (defgeneric (setter positioner) (stream n))
  42.   
  43.   (defun input (stream)
  44.     ((inputter stream)))
  45.  
  46.   (defun output (stream x)
  47.     ((outputter stream) x))
  48.  
  49.   (defmethod initialize ((x <stream>) lst)
  50.     (let ((next (scan-args 'next lst required-argument))
  51.       (self (call-next-method)))
  52.       (push self next)))
  53.  
  54.   (defun push (new next inits)
  55.     (map (lambda (protocol)
  56.        ((protocol-set-function protocol) new
  57.         (protocol-compute-function next inits)))
  58.      (stream-class-protocol (class-of new))))
  59.   
  60. (defclass <stream> ()
  61.   ()
  62.   metaclass <stream-class>
  63.   metaclass-initargs 
  64.   (direct-stream-fns
  65.    (list (protocol-object compute-input-function inputter (setter inputter))
  66.      (protocol-object compute-output-function outputter (setter outputter))))
  67.   )
  68.  
  69. (defmethod compute-input-function ((obj <stream>))
  70.   (lambda (next inits)
  71.     (inputter next)))
  72.  
  73. (defmethod compute-output-function ((obj <stream>))
  74.   (lambda (next inits)
  75.     (inputter next)))
  76.  
  77.   ;; end module
  78.   )
  79.  
  80. (defclass <line-counting-stream> (<stream>)
  81.   ((count initform 0 accessor stream-line-count))
  82.   )
  83.  
  84. (defmethod compute-output-function ((x <line-counting-stream>) next args)
  85.   (let ((next (outputter next)))
  86.     (generic-lambda (c)
  87.             method (((c <character>))
  88.                 (when (eq c #\newline)
  89.                   (inc-posn x))
  90.                 (next c))
  91.             method (((s <string>))
  92.                 (do (lambda (c)
  93.                   (when (eq c #\newline)
  94.                     (inc-posn x))
  95.                   (next c))
  96.                 s)))))
  97.  
  98. (defmethod compute-position-function ((x <line-counting-stream>) next args)
  99.   (lambda ()
  100.     (error "can't change position" <stream-error>)))
  101.  
  102. (defmethod compute-position-setter-function 
  103.  ((x <line-counting-stream>) next args)
  104.   (lambda (pos)
  105.     (error "can't change position" <stream-error>)))
  106.  
  107. NB: should have some predicates: 
  108.   stream-object-type
  109.   input-stream-p
  110.   output-stream-p
  111.   positionable-stream-p
  112.   
  113.  
  114.